home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue39 / Alfresco / HeapSort.pas next >
Encoding:
Pascal/Delphi Source File  |  1998-10-04  |  4.1 KB  |  115 lines
  1. {*********************************************************}
  2. {* HeapSort                                              *}
  3. {* Copyright (c) Julian M Bucknall 1998                  *}
  4. {* All rights reserved.                                  *}
  5. {*********************************************************}
  6. {* Heapsort algorithm                                    *}
  7. {*********************************************************}
  8.  
  9. {Note: this unit is released as freeware. In other words, you are free
  10.        to use this unit in your own applications, however I retain all
  11.        copyright to the code. JMB}
  12.  
  13. unit HeapSort;
  14.  
  15. interface
  16.  
  17. uses
  18.   SysUtils, Classes;
  19.  
  20. type
  21.   TaaLessFunction = function (const X, Y : pointer) : boolean;
  22.     {function prototype to compare two items and return true if item X
  23.      is STRICTLY LESS than item Y}
  24.  
  25. procedure AAHeapSort(var aItemArray    : TList;
  26.                          aLeft, aRight : integer;
  27.                          aLessThan     : TaaLessFunction);
  28.   {-Heap sort an array (passed as a TList) in the range aLeft to
  29.     aRight}
  30.  
  31. implementation
  32.  
  33. procedure AAHeapSort(var aItemArray    : TList;
  34.                          aLeft, aRight : integer;
  35.                          aLessThan     : TaaLessFunction);
  36. var
  37.   Inx      : integer;
  38.   FromInx  : integer;
  39.   ChildInx : integer;
  40.   ListCount: integer;
  41.   Item     : pointer;
  42. begin
  43.   {if there's nothing to do, do it}
  44.   ListCount := aRight - aLeft + 1;
  45.   if (ListCount <= 1) then
  46.     Exit;
  47.  
  48.   {first, turn the array into a heap; this is complicated by the fact
  49.    that all our indexes are offset by aLeft}
  50.   for Inx := ((ListCount - 2) div 2) downto 0 do begin
  51.     Item := aItemArray[Inx+aLeft];
  52.     FromInx := Inx;
  53.     ChildInx := succ(FromInx * 2);
  54.     {while there is at least a left child...}
  55.     while (ChildInx <= aRight-aLeft) do begin
  56.       {if there is a right child, calculate the index of the larger
  57.        child}
  58.       if (succ(ChildInx) <= aRight-aLeft) and
  59.          aLessThan(aItemArray[ChildInx+aLeft], aItemArray[succ(ChildInx)+aLeft]) then
  60.         inc(ChildInx);
  61.       {if our item is greater or equal to the larger child, we're done}
  62.       if not aLessThan(Item, aItemArray[ChildInx+aLeft]) then
  63.         Break;
  64.       {otherwise move the larger child up the tree, and move our item
  65.        down the tree and repeat}
  66.       aItemArray[FromInx+aLeft] := aItemArray[ChildInx+aLeft];
  67.       FromInx := ChildInx;
  68.       ChildInx := succ(FromInx * 2);
  69.     end;
  70.     {store our item in the correct place}
  71.     aItemArray[FromInx+aLeft] := Item;
  72.   end;
  73.  
  74.   {if there are only two items, the above will have sorted them}
  75.   if (ListCount = 2) then
  76.     Exit;
  77.  
  78.   {now progressively pop off the largest element and reduce the heap
  79.    size by one, storing the largest element in the vacated space;
  80.    again this is complicated by the fact that all our indexes are
  81.    offset by aLeft}
  82.   while (ListCount > 1) do begin
  83.     {save the last item (we'll pretend it's at the root), replace it
  84.      with the root item (ie the largest)}
  85.     Item := aItemArray[aRight];
  86.     aItemArray[aRight] := aItemArray[aLeft];
  87.     {reduce the size of the heap}
  88.     dec(ListCount);
  89.     dec(aRight);
  90.     {trickle down from the root}
  91.     FromInx := 0;
  92.     ChildInx := succ(FromInx * 2);
  93.     {while there is at least a left child...}
  94.     while (ChildInx <= aRight-aLeft) do begin
  95.       {if there is a right child, calculate the index of the larger
  96.        child}
  97.       if (succ(ChildInx) <= aRight-aLeft) and
  98.          aLessThan(aItemArray[ChildInx+aLeft], aItemArray[succ(ChildInx)+aLeft]) then
  99.         inc(ChildInx);
  100.       {if our item is greater or equal to the larger child, we're done}
  101.       if not aLessThan(Item, aItemArray[ChildInx+aLeft]) then
  102.         Break;
  103.       {otherwise move the larger child up the tree, and move our item
  104.        down the tree and repeat}
  105.       aItemArray[FromInx+aLeft] := aItemArray[ChildInx+aLeft];
  106.       FromInx := ChildInx;
  107.       ChildInx := succ(FromInx * 2);
  108.     end;
  109.     {store our item in the correct place}
  110.     aItemArray[FromInx+aLeft] := Item;
  111.   end;
  112. end;
  113.  
  114. end.
  115.